perm filename T1X.OL2[M11,LCS] blob
sn#409393 filedate 1979-01-04 generic text, type T, neo UTF8
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
SUBROUTINE TRANS(JJJ)
CIN DIMENSION IINS(108)
C W(35) FOR PARAMETERS
CIN COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
COMMON /TR/I(80),RX(100),JX(100),LX(12),K
1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN /IFIRST/IFIRST,IDT
1 /INST/INST(27)
1 /WDZ/WDZ(14),JWD(12)
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
COMMON LL /P/W(1) /CONV/ICONV /FQDR/FQDR(28,27),INSN
INTEGER FQDR
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
CXX DOUBLE PRECISION IDBL,JANP,JBLA,IPERC,JFLNM,IDBG,
CXX 1 INST,INAM,JSEMI,ICOLON
EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
CXX DATA LX/' ',';', '*','/','-','+'
CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
DATA LX/' ',';', '*','/','-','+'
1,"575004020100,'=','<' ,',' ,'(', ')'/, IOPEN/-1/
1 , IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/
1,JBLA/' '/,IDBG/'# '/,JDBG/'#'/,JSEMI/';'/
C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
1,IEXP/'!'/,IPERC/'% '/,JANP/'& '/
1,IANP/'&'/,ICONV/-1/,ICOLON/':'/
1,IALT/"765004020100/
CXX 1,IALT/'"'/
C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
GO TO (555,5002) JJJ
555 LLLL=0
401 IF(IFIRST)404, 5,600
404 IGEN=-1
IF(INUM.NE.0)GO TO 30
DO 411 K=1,27
411 INST(K)=0
CIN DO 411 K=1,108
CIN411 IINS(K)=0
C ZERO OUT INSTR. NAME ARRAY.
30 IPLAY=0
ENDX=0
JSEM=0
INS=-1
402 IDEV=1
TYPE 1
1 FORMAT(' INPUT? '$)
100 FORMAT(' >'$)
2 FORMAT(A4)
ACCEPT 2,IDBL
C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
IF(IDBL.NE.JBLA)GO TO 400
IDEV=5
GO TO 5
400 IF(IDBL.EQ.JANP)GO TO 603
C!*** & IS PRNT-NOPRNT FLIPFLOP
IF(IDBL.NE.IDBG)GO TO 410
4448 TYPE 4023
4446 TYPE 4445
ACCEPT 51,KI
IF(KI.EQ.0)GO TO 4022
IF(KI.GT.0)GO TO 4447
C******** THIS STUFF FOR DIAGNOSIS
IF(KI.EQ.-1)TYPE 2325,IGEN
IF(KI.EQ.-2)TYPE 2325,IPRNT
IF(KI.EQ.-3)TYPE 2325,IPLAY
IF(KI.EQ.-4)TYPE 2325,JSEM
IF(KI.EQ.-5)TYPE 2325,J
IF(KI.EQ.-6)TYPE 2325,MM
GO TO 4446
4022 IF(IDEV.EQ.1)GO TO 402
C GO BACK TO 'INPUT' OR '>'
GO TO 502
C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
4447 TYPE 2326,LX(KI)
TYPE 2325,LX(KI)
GO TO 4446
4445 FORMAT(' TYPE LX NUMB. '$)
4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
CCC IF(IDBL.EQ.'%')GO TO 604
C!*** % IS WRT-NOWRT FLIPFLOP
C! % WRITES BINARY FILE.
2324 FORMAT(1X12F/)
2325 FORMAT(1X5I/)
2326 FORMAT(1X80A1)
410 IF(IDBL.EQ.ICOLON)CALL EXIT
C TYPE ':' TO EXIT AND CLOSE ALL FILES.
CALL IFILE(1,IDBL)
CX CALL OPEN(1,IDBL,0,'RDO')
4 FORMAT(80A1)
C****************
CX TYPE 2325,JSEM
CX TYPE 2325,J
CX TYPE 2325,MM
5 IF(JSEM.AND.J.LT.MM)GO TO 305
IF(JSEM.NE.99)GO TO 502
IFIRST=IFIRST+10
GO TO 555
600 JSEM=0
IFIRST=IFIRST-10
INS=-1
502 IF(IDEV.NE.5)GO TO 601
CX TYPE 2325,IDEV
C*******************************
IF(IGEN.NE.2)IGEN=-1
503 TYPE 100
CX601 TYPE 2325,INS
C*******************************
601 READ(IDEV,4,END=404)I
IF(I1.EQ.ICOLON)CALL EXIT
C TYPE ':' TO EXIT AND CLOSE FILES.
IF(IDEV.EQ.5)GO TO 1232
KI=80
1233 IF(I(KI).NE.IBLA)GO TO 1234
KI=KI-1
IF(KI.GT.0)GO TO 1233
1234 IF(JPRNT.LT.0)TYPE 2326,(I(IJI),IJI=1,KI)
GO TO 602
1232 IF(I(1).EQ.IBLA)GO TO 404
C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?'
IF(I(1).EQ.JDBG)GO TO 4448
C TYPE '#' FOR SOME DEBUGGING
CCC IF(I(1).EQ.'%')GO TO 604
C!*** %=WRITES BINARY FILE FOR21.DAT
IF(I(1).NE.IANP)GO TO 602
C!*** &=TYPE OUT MUS5 NUMBERS
603 JPRNT=-JPRNT
IF(IDEV.EQ.1)GO TO 402
C IDEV=1 = GO BACK TO 'INPUT'
GO TO 502
CCC604 JWRT=-JWRT
C!*** DEFAULT IS NO-WRITE BINARY
CCC GO TO 401
602 IF(I(1).NE.IALT)GO TO 408
CCC IF(I(2).NE.'I')GO TO 605
C!***<ALT>I(NSTRUMENT LIST;) ALT IS DBL QUOTE IN THIS PROG. FOR NOW.
DO 606 K=1,INUM
CC JK=NPAR(K)-2
JK=INSNUM(K)
MM=NPAR(JK)-2
606 TYPE 607,INST(K),JK,MM
CIN606 TYPE 607,(INST(K,L),L=1,4),JK,NPAR(JK)
CC606 TYPE 607,(INST(K,L),L=1,4),INSNUM(K),JK
GO TO 5
607 FORMAT(1X,A4,' NUM=',I2,' PARAMS=',I2)
CIN607 FORMAT(1X,4A1,' NUM=',I2,' PARAMS=',I2)
C!*** PRINTS INST INFO.
CCC605 SBFILN=FILNM
CCCCC CALL PLAY
C!**** GO PLAY SOMETHING
CCC GO TO 5
408 IF(I(1).NE.IEXP)GO TO 1408
C TRIGGERS ICONV FLIPFLOP
IF(ICONV)GO TO 2408
ICONV=-1
TYPE 3408
GO TO 502
2408 ICONV=0
TYPE 4408
GO TO 502
3408 FORMAT(' OUTPUT=TEST.SND'/)
4408 FORMAT(' OUTPUT=TEST.DAT'/)
1408 DO 407 K=1,100
407 JX(K)=IBLA
DO 405 K=1,80
IF(I(K).EQ.LESS)GO TO 5
405 IF(I(K).NE.IBLA)GO TO 406
GO TO 5
406 MM=0
DO 4061 J=2,100,2
4061 RX(J)=0
J=-1
IPRNT=0
JI=0
9 M=0
N=JI+1
6 JI=JI+1
KCHAR=I(JI)
DO 7 L=1,12
7 IF(KCHAR.EQ.LX(L))GO TO 8
M=M+1
GO TO 6
C!**** NO STRING CAN EXCEED 10 CHARS.
8 IF(KCHAR.EQ.LESS)GO TO 15
IF(M.EQ.0)GO TO 140
IF(M.GT.10)M=10
MM=MM+1
IF(MM.LE.50)GO TO 88
TYPE 888,(I(JJ),JJ=N,N+9)
STOP
888 FORMAT(' LINE TOO LONG -- ',10A1)
88 JJ=I(N)
IF(JJ.GT.'9')GO TO 16
IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
CXX IF(JJ.GT.8249)GO TO 16
CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
C**** 8240='0' 8249='9'
C!***** JUMP IF 1ST CHAR. IS A LETTER.
Y=0
DOT=10.
DO 18 JK=N,N+M-1
JA=I(JK)
IF(JA.NE.IDOT)GO TO 17
DOT=.1
GO TO 18
CXX17 X=JA-8240
17 X=NASCI(JA)
C!**** CHANGE ASCII INTO NUMBER
IF(DOT.LT.1)GO TO 19
Y=Y*DOT+X
GO TO 18
19 Y=Y+X*DOT
DOT=DOT/10.
18 CONTINUE
RX(MM*2-1)=Y
RX(MM*2)=-9999.0
GO TO 140
CCC16161 FORMAT(1X,I,3X10A1)
16 JK=MM*2-1
CX JX(JK)=0
CX RX(JK)=0
CX JX(JK+1)=0
CX RX(JK+1)=0
CALL MPACK(M,I(N),JX(JK),N)
C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
IJ=JX(JK)
CCC IF(JPRNT)TYPE 16161,IJ,(I(KHH),KHH=N,N+M-1)
IF(IJ.GE.0)GO TO 144
CC IF(IJ.GE.0)GO TO 244
C IF IJ < 0, THEN IT'S A LETTER
JX(MM*2)=M
C SAVE THE WD CNT OF POTENTIAL INST. NAME.
CCCC GO TO 10
GO TO 143
144 IF(IJ.NE.408)GO TO 140
TYPE 244,WDZ,JWD
GO TO 503
244 FORMAT(15(1XA4))
140 IF(IJ.NE.413)GO TO 143
CCC140 IF(IXJ.NE.'UNIT')GO TO 143
INS=1
C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
GO TO 5
143 IF(KCHAR.EQ.IBLA)GO TO 10
IF(L.EQ.8)KCHAR=IAROW
C!::: CHANGE = INTO ←
MM=MM+1
KI=MM*2-1
JX(KI)=KCHAR
CC JX(MM*2-1)=K
10 IF(I(JI+1).NE.IBLA)GO TO 11
JI=JI+1
GO TO 10
11 IF(JI.LT.80)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
15 MM=MM*2
IF(IJ.NE.404)GO TO 142
CCC IF(IXJ.NE.KPRNT)GO TO 142
INS=-1
C!***** FOR 'PRINT'
IPRNT=-1
142 J=-1
IF(INS.LT.0)GO TO 305
IF(INS.EQ.2)GO TO 305
CC26 IF(IJ.NE.12)GO TO 127
CCC26 IF(IXJ.NE.'END')GO TO 127
MM=0
INS=-1
C!***** NOW INITIALIZATION COMPLETE
GO TO 5
50 IF(IGEN)308,309,309
309 LL=LL-1
IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
C!*** FOUND 'END'
GO TO 59
308 W1=1
IK=W2
IF(LL.GT.NPAR(IK))GO TO 56
54 IF(LL.LT.3)LL=3
DO 55 K=LL,NPAR(IK)
55 W(K)=P(K-2)
C!***** GET INFO ALREADY IN PARAMS
56 DO 57 K=3,LL
57 P(K-2)=W(K)
C!**** FILL UP P LIST AGAIN
X=W3
C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
W3=W2
W2=X
58 LL=NPAR(IK)
DO 52 K=5,LL
KI=FQDR(K-4,IK)
CC X=FQDR(K-4,IK)
IF(KI)53,52,2352
CC IF(X.EQ.0)GO TO 52
CC IF(X)GO TO 53
2352 W(K)=RMAG/W(K)
GO TO 52
53 W(K)=RMAG*W(K)
52 CONTINUE
IF(ENDX.LT.W2+P2)ENDX=W2+P2
CC*** NO LONGER NEEDED W(LL)=RMAG/W(4)
C!********* PUT MAG/P2 AT END
59 IF(W1.NE.2.)GO TO 592
IF(LL.EQ.2)GO TO 597
C JUMP IF 'END' OF INS DEF.
IF(LL.NE.3)GO TO 595
C JUMP IF NOT AN INST DEF.
PSV=0
SV=35
C EXPLAIN USE OF STORAGE PARAMS!!
INSN=W3
C INS DEF NUM.
CC JINS=INUM
C LIST OF INST NAMES MUST FOLLOW 'INS 0 N;' !!!ALWAYS!!!
CIN596 INUM=INUM+1
CIN596 READ(IDEV,2)INST(INUM)
596 READ(IDEV,2,END=587)INAM
IF(INAM.EQ.JSEMI)GO TO 595
C LIST OF INST NAMES TERMINATES WITH ';'.
DO 588 K=1,INUM
IF(INAM.NE.INST(K))GO TO 588
INST(K)=INAM
INSNUM(K)=INSN
GO TO 589
587 PAUSE 'MISSING SEMICOLON'
588 CONTINUE
INUM=INUM+1
INST(INUM)=INAM
CIN READ(IDEV,4)(INST(INUM,K),K=1,4)
CIN IF(INST(INUM,1).EQ.ISEMI)GO TO 599
C LIST OF INST NAMES TERMINATES WITH ';'.
INSNUM(INUM)=INSN
589 IF(JPRNT)TYPE 244,INAM
CIN IF(JPRNT)TYPE 2326,(INST(INUM,K),K=1,4)
GO TO 596
CIN599 INUM=INUM-1
595 DO 593 K=3,LL
X=W(K)
IF(X.LT.0.OR.X.GT.100)GO TO 593
IF(X.GT.PSV)PSV=X
C CHECK FOR OVERLAPPING PARAM NUMS.
593 CONTINUE
IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
1 .AND.W3.NE.115)GO TO 592
C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
X=W3
594 LL=LL+1
W(LL)=SV
SV=SV-1
C DECREMENT THE HIGH PARAM NUM.
IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
CIN IF(SV.LT.PSV)CALL ERROR(5)
C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
IF(X.NE.111.AND.X.NE.104)GO TO 592
IF(X.EQ.111)X=0
IF(X.EQ.104)X=111
GO TO 594
CC597 DO 598 K=JINS+1,INUM
CC598 NPAR(K)=PSV
597 NPAR(INSN)=PSV
C SAVE THE HIGHEST PARAM NUM.
592 IF(JPRNT.GE.0)GO TO 591
CC TYPE 590,KNAM
KNAM=IBLA
TYPE 51,LL,(W(K),K=1,LL)
CXX WRITE(22,51)LL,(W(K),K=1,LL)
C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
591 IF(JWRT.GE.0)GO TO 500
CZZ IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
CXX IF(IOPEN.LT.0)CALL OPEN(21,JFLNM,0,'NEW',,,'UNF')
C OPENS FILE, IF NOT ALREADY OPEN.
CZZ WRITE(21)LL,(W(K),K=1,LL)
IDT=2
RETURN
5002 IOPEN=0
500 IFIRST=0
IF(IGEN.EQ.0)IGEN=-1
IF(W1.NE.6)GO TO 555
RETURN
C W1=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
590 FORMAT(I6)
CCC590 FORMAT(1XA5,1X$)
306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
IPRNT=0
C!** RESET NO-PRNT FLAG
JSEM=0
C!** RESET SEMICOLON FLAG
INS=-1
IF(J.GE.MM-1)GO TO 5
C!** GO READ ANOTHER LINE
305 CALL MSCAN
303 IF(IPRNT.LT.0)GO TO 306
IF(J.LT.MM)JSEM=-1
C!**** STILL MORE CHARS TO COME.
IF(ENDX.GE.0)GO TO 302
ENDX=0
GO TO 500
302 IF(JSEM)50,5,5
51 FORMAT(I3,35F10.3)
307 FORMAT('+',F8.2,$)
1307 FORMAT(F10.3)
END
FUNCTION NASCI(N)
DATA IEX/536870912/,IZERO/'0'/
C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
NASCI=(N-IZERO)/IEX
C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
END
SUBROUTINE CLOSIT(LL,W)
COMMON /KNAM/A,B,C,IOPEN
IOPEN=-1
RETURN
END